Graphics Plus/Graphics Plus.iso/msdos/raytrace/pov/gen/povclk/envunit.pas

Pascal/Delphi Source File | 1980-01-01 | 22.9 KB | 865 lines

unit EnvUnit; {                 Version 2.8                      88/11/07

Handy little routines to simplify using the environment string.

See the example program ENVTEST.PAS, for hints on how to use this unit.

MOST LIKELY TO BE USED:   1) FFind - search the path for a named file and
                                     return the fully qualified file name
                                     if it is found.

                          2) PathTo - search the path for a named file;
                                      return the path to that file if found

                          3) ParamStr - the complete parameter string


This program is hereby donated to the public domain. It may be freely copied,
used & modified without charge or fee.

Author        :  Mike Babulic
                 3827 Charleswood Dr. N.W.
                 Calgary, Alberta
                 CANADA
                 T2L 2C7
Compuserve ID :  72307,314


Modification Log:
-----------------
  88/11/07 - Version 2.8 - EnvStrPtr changed so root environment could be
             found in DOS 2.0-3.2. Offset $2C from the root PSP is 0000 in
             these early DOS's, so an alternative method of finding the
             envirinment must be used. (see Dr Dobb's Journal, Dec.88, p.57)
}


interface

uses Dos;


{$IFDEF VER40}   {These objects are already in TP Version 5's Dos Unit}
                 {I've included them so you can upgrade gracefully}

type
   PathStr = string[79];
   DirStr  = string[67];
   NameStr = string[8];
   ExtStr  = string[4];

function DosVersion: word;  { lo = version (ex. 3);  hi = fraction (ex. .2) }

function EnvCount: integer;              {number of Environment Strings}
function EnvStr(Index:integer): string;  {get Env. String number index}
function GetEnv(EnvVar:string): string;  {get Env. String named by EnvVar}

function FExpand(Path:PathStr):PathStr;
  {expand the path to a fully qualified file name}
function FSearch(Path:PathStr;DirList:string):PathStr;
   {Search DirList (paths separated by ";") for Path & return full name of
    this file}
procedure FSplit(Path:PathStr; var Dir:DirStr; var Name:NameStr; var Ext:ExtStr);
{$ENDIF}



  var   MyPath : string;        {Path & Name of the running program}
        MyDir  : DirStr;
        MyName : NameStr;
        MyExt  : ExtStr;


  function DOS_Version: integer;
      {Returns the version of DOS being used (ex. 302 is DOS 3.2)}


  function ParamString: String;
      {Returns the complete parameter string}

  function EnvStrPtr:Pointer;
      {Point to environment strings}

  function EnvSize:LongInt;
      {Size of the current environment in bytes}

  function MaxEnvSize:LongInt;
      {Maximum size of the current environment in bytes}


  var PSP : word;  {Program Segment Prefix;  initially = PrefixSeg}

  function ProgPath: PathStr;    {Path to program owning current PSP}
  function ProgDir:  DirStr;        {Directory of program owning current PSP}
  function ProgName: NameStr;       {Name of program owning current PSP}
  function ProgExt:  ExtStr;        {Extension of program owning current PSP}

  procedure UseMyPSP;
      {Use the program's PSP to find the environment}
  procedure UseParentPSP;
      {Use the parent of the current PSP to find the environment}
  procedure UseRootPSP;
      {Use the parent of the current PSP to find the environment}


  procedure DelEnv(name:String);
      {delete the named string from the current environment}

   function SetEnv(name,env:String):boolean;
      {set the named environment string to env}

   function SetPath(path:String):boolean;
      {set the environment "PATH=" string to path}


  function FirstEnv:String;
      {Get the First Environment string}
  function NextEnv:String;
      {Get the Next Environment string}
  procedure SkipEnv;
      {Skip the Next Environment string}
  function EOEnv:Boolean;
     {True if End Of Environment}


  function GetEnvPtr(name:String):Pointer;
      {return a pointer to the named environment variable's string}


  function FirstNamed(name,delim:String):String;
     {Get the first string in an the named environment specification
         eg. If name = 'PATH' and delim = ';' then get the first path string
             "Path" strings are delimited by semicolins: ";" }
  function NextNamed:String;
     {Get the next string in an environment specification}
  function EONamed:Boolean;
     {True if end of environment specification}


  function FirstPath:String;
     {Almost the same as Firstnamed('PATH',';'), but appends a '\' to the
      string if needed}
  function NextPath:String;

{File Utilities}

  const AllowWildcards : boolean = TRUE;
     {Used by FileExists and routines that depend on it (PathTo, FFind).
      If TRUE these functions will allow wildcard characters in a file name}

  function ContainsWildcards(filename:string):boolean;
     {True if filename contains wildcard characters}


  function PathTo(filename:string):string;
     {Searches the environment PATH and returns a path to the named file.
        Check the current directory,
        then search the environment PATH,
        then check the directory containing the calling program (MyDir).
        If the file is still not found, return a null string ('')}


  const  FFindErr = '.';

  function FFind(filename:string):string;
     {Find the File called "filename".
        Check the current directory,
        then search the environment PATH,
        then check the directory containing the calling program (MyDir).
        - if "filename" is found return the fully qualified file name
          of the filename.
        - if "filename" is NOT found then return FFindErr.
          - a period is returned because if you write something like:
                Assign(aFile,FFind('MISSING.TXT'));
                Reset(aFile);
            and FFind returned '' when it failed then aFile would be assigned
            to the standard INPUT file (usually the keyboard)! }

{misc}
  function  FileExists(name:string):Boolean;      {True if named file exists}
  procedure PtrInc(var p:Pointer; n: Longint);    {Increment pointer by n}
  function  PtrDiff(p1,p2:Pointer):Longint;       {p1-p2 in Bytes}
  function  UpperStr(s:string):string;            {string to uppercase}


{----------------------------------------------------------------------------}

implementation

  type pointr = record  lo,hi: word  end;

  procedure PtrInc(var p:Pointer; n: Longint);   {Increment pointer by n}
    var
       pt : pointr   absolute  p;
       c  : pointr   absolute  n;
    begin
      n := pt.lo + n;
      pt.hi := (n AND $FFFF0000) shr 4 + pt.hi;
      pt.lo := c.lo;
    end;

  function PtrDiff(p1,p2:pointer): LongInt;
    var
       a : pointr   absolute  p1;
       b : pointr   absolute  p2;
    begin
      PtrDiff := (a.hi-b.hi) shl 4 + (a.lo-b.lo)
    end;

  function  UpperStr(s:string):string;            {string to uppercase}
    var i : integer;
    begin
      for i := 1 to length(s) do
        UpperStr[i] := upcase(s[i]);
      Upperstr[0] := s[0];
    end;


{-----------------------------------------------------------------------------}



  type WordP = ^word;

       MCB = packed record
         kind   : char; {is 'M' or 'Z'}
         PID    : word;
         PCount : word; {# of paragraphs}
         end;

       MCBPtr = ^MCB;


  function EnvSeg : word;    {Segment containing the environment}
    var
      ESeg : word;
      done,found   : boolean;
    begin
      ESeg := WordP(Ptr(PSP,$2C))^;
      if ESeg = 0 then begin {DOS 2.0-3.2 root zeros this pointer, so..}
        ESeg := Pred(PSP);   {hunt through the MCB chain for ESeg}
        repeat
          ESeg := ESeg + MCBPtr(Ptr(ESeg,0))^.PCount + 1;
          with MCBPtr(Ptr(ESeg,0))^ do begin
            found  := (PID=PSP);
            done   := found         {found it!}
                   or (PID<>0)      {past command.com's storage}
                   or (kind='Z');   {end of the chain}
          end;
        until done;
        Eseg := Succ(ESeg);
        if not found then ESeg := 0;
      end;
      EnvSeg := ESeg;
    end;


  function EnvStrPtr:Pointer;
    begin
      EnvStrPtr := Ptr(EnvSeg,0);
    end;

  function EnvSize: LongInt;
    var  p1,p2 : ^char;
    begin
      p1 := EnvStrPtr;
      p2 := p1;
      {move past environment strings}
        repeat
          while p2^<>#0 do begin
            PtrInc(Pointer(p2),1);
          end;
          PtrInc(Pointer(p2),1);
        until p2^=#0;
      if Dos_Version >= 300 then begin  {skip program name}
        PtrInc(Pointer(p2),3);
        while p2^<>#0 do
          PtrInc(Pointer(p2),1);
        PtrInc(Pointer(p2),1);
      end;
      EnvSize := PtrDiff(p2,p1)+1;
    end;

  function MaxEnvSize:LongInt;
    begin
      MaxEnvSize := MCBPtr(Ptr(Pred(EnvSeg),0))^.PCount  shl  4;
    end;

  procedure UseMyPSP;
    begin
      PSP := PrefixSeg;
    end;

  Procedure UseParentPSP;
    begin
      PSP := WordP(Ptr(PSP,$16))^;
    end;

  Procedure UseRootPSP;
    var oldPSP : word;
    begin
      repeat
        oldPSP := PSP;
        UseParentPSP;
      until PSP=oldPSP;
    end;




{-----------------------------------------------------------------------------}

  Type ASCIIz = array [0..255] of char;
       ASCIIptr = ^ASCIIz;

  function LenZ(var c:ASCIIz): Word;  {length of ASCIIz string}
    var i: Word;
    begin
      for i := 0 to MaxInt do
        if c[i]=#0 then begin
          LenZ := i;
          exit;
        end;
      LenZ := MaxInt;
    end;

  function StrZn(var c:ASCIIz;MaxLen:integer):string;
    label done;
    var i,j: integer;
    begin
      MaxLen := MaxLen-1;
      for i := 0 to MaxLen do begin
       if c[i]=#0 then goto done;
        StrZn[i+1] := c[i];
      end;
      i := MaxLen+1;
      done: StrZn[0] := chr(i);
    end;

  function StrZ(var c:ASCIIz):string;
    const MaxLen = 254;
    label done;
    var i,j: integer;
    begin
      for i := 0 to MaxLen do begin
       if c[i]=#0 then goto done;
        StrZ[i+1] := c[i];
      end;
      i := MaxLen+1;
      done: StrZ[0] := chr(i);
    end;


  function ToDelim(d:string; var s:string):integer;
    var i:integer;
    begin
      i := pos(d,s);    {length to first delimiter}
      if i>0 then
        s[0] := chr(i-1)
      else
        i := length(s);
      ToDelim := i;
    end;


{----------------------------------------------------------------------------}


function ParamString: String;
  type StrPtr = ^String;
  begin
    ParamString := StrPtr(Ptr(PrefixSeg,$80))^;
  end;


{----------------------------------------------------------------------------}


  var EnvPtr : ASCIIptr;

  function FirstEnv:String;
    var s: string[255];
        i: integer;
    begin
      EnvPtr := EnvStrPtr;
      FirstEnv := NextEnv;
    end;

  function NextEnv:String;
    var s: string;
        i: integer;
    begin
      if EOEnv then
        NextEnv := ''
      else begin
        s := StrZ(EnvPtr^);
        i := ToDelim(#0,s);
        PtrInc(Pointer(EnvPtr),i+1);
        NextEnv := s;
      end;
    end;

  procedure SkipEnv;
    var i : integer;
    begin
      for i := 1 to MaxInt do
        if EnvPtr^[i]=#0 then begin
          PtrInc(Pointer(EnvPtr),i+1);
          exit
        end;
    end;

  function GetEnvPtr(name:string):Pointer;
    var i : integer;
    begin
      for i := 1 to length(name) do name[i] := upcase(name[i]);
      name := name + '=';
      EnvPtr := EnvStrPtr;
      repeat
        if strZn(EnvPtr^,length(name)) = name then begin
          GetEnvPtr := EnvPtr;
          exit;
        end;
        SkipEnv;
      until EoEnv;
      GetEnvPtr := EnvPtr;
    end;

   function EOEnv:Boolean;
     begin
       EOEnv := (EnvPtr^[0]=#0);
     end;

{----------------------------------------------------------------------------}

   procedure DelEnv(name:String);
     var p1,p2 : ASCIIptr;
     begin
       p1 := GetEnvPtr(name);
       if not EoEnv then begin
         SkipEnv;
         p2 := EnvPtr;
         move(p2^,p1^, EnvSize - PtrDiff(p2,EnvStrPtr));
       end;
     end;

   function SetEnv(name,env:String):boolean;
     var p1 : ASCIIptr;
         l  : LongInt;
     begin
       DosError := 0;
       {Null strings remove the variable from the environment}
         if env='' then begin
           DelEnv(name);
           SetEnv := True;
           exit;
         end;
       SetEnv := FALSE;
       {Make sure env isn't too big}
         p1 := GetEnvPtr(name); {null string if not found}
         l  := LenZ(p1^);
         if l=0 then l := -1; {trick to add 1 to the new length}
         if MaxEnvSize < length(name)+1+length(env) + EnvSize - l then begin
           DosError := 8; {Not Enough Memory}
           exit;
         end;
       DelEnv(name);
       {insert new string}
         env := UpperStr(name)+'='+env;
         {go to end of environment}
           EnvPtr := EnvStrPtr;
           while not EoEnv do SkipEnv;
         {make room}
           p1 := EnvPtr;  PtrInc(Pointer(p1),length(env)+1);
           move(EnvPtr^,p1^,EnvSize-PtrDiff(EnvPtr,EnvStrPtr)-1);
         {move in data}
           move(env[1],EnvPtr^,length(env));
           ASCIIptr(EnvPtr)^[length(env)] := #0;
       SetEnv := TRUE;
     end;

   function SetPath(path:String):boolean;
     begin
       SetPath := SetEnv('PATH',UpperStr(path));
     end;

{----------------------------------------------------------------------------}


  var namePtr : ASCIIptr;
      dummy  : LongInt;
      namedDelim : string;

  function EONamed:Boolean;
    begin
      EONamed := (namePtr^[0]=#0);
    end;

  function FirstNamed(name,delim:String):string;
    var
        s: string;
        i: integer;
    begin
      namePtr    := GetEnvPtr(name);
      namedDelim := delim;
      if EoEnv then begin
        FirstNamed := '';
        exit;
      end;
      PtrInc(Pointer(namePtr),length(name)+1); {skip past the name}
      s := StrZ(namePtr^);
      i := ToDelim(delim,s);
      FirstNamed := s;
      PtrInc(Pointer(namePtr),length(s)+1);
    end;

  function NextNamed:string;
    var
        s: string;
        i: integer;
    begin
      if EONamed then begin
        NextNamed := '';
        end
      else begin
        s := StrZ(namePtr^);
        i := ToDelim(NamedDelim,s);
        PtrInc(Pointer(namePtr),i);
        NextNamed := s;
      end;
    end;



{-----------------------------------------------------------------------------}


  var  FileInfo :  SearchRec;


  function ContainsWildcards(filename:string):boolean;
    begin
      ContainsWildcards := ((pos('?',filename)>0) or (pos('*',filename)>0))
    end;


  function FileExists(name:string):Boolean;
    begin
      if (not AllowWildcards) and ContainsWildcards(name) then begin
        FileExists := FALSE;
        exit;
      end;
      FindFirst(Name,0,FileInfo);
      FileExists := (DosError=0);
    end;


{-----------------------------------------------------------------------------}

{----------------------------------------------------------------------------}

  function DirDelim(s:String):String;
    var i: integer;
        c: char;
    begin
      DirDelim := '';
      i := length(s);
      while (i>0) and (s[i]=' ') do i := pred(i);
      if i<=0 then exit;
      s[0] := chr(i);
      if (i<1) or not (s[i] IN [':','\']) then
        s := s + '\';
      DirDelim := s;
    end;

  function FirstPath: String;
    begin
      FirstPath := DirDelim(FirstNamed('PATH',';'));
    end;

  function NextPath: String;
    begin
      NextPath := DirDelim(NextNamed);
    end;

  function SpecifiesDrive(var filename:string):boolean;
    begin
      SpecifiesDrive := (filename[2]=':') and (length(filename)>1)
    end;


  function PathTo(filename:string):string;
    var path: string;
        found: boolean;
    procedure CurrentPath;
      begin
        if FileExists(path+filename) then begin   {Check Current Directory}
          if  (filename[1]='\') then begin  {root directory}
            found := TRUE;
           end
          else begin
            if SpecifiesDrive(path) then
              GetDir(ord('A')-ord(upcase(path[1]))+1,path)
            else
              GetDir(0,path);
            found := FileExists(path+filename);
          end;
          path := DirDelim(path);
        end;
      end;
    begin
      found := FALSE;
      if filename<>'' then begin
        if SpecifiesDrive(filename) then begin
          path     := Copy(filename,1,2);
          filename := Copy(filename,3,SizeOf(FileName));
          CurrentPath;                       {Check the Named Disk Drive}
        end;
        if not found then begin
          path := '';
          CurrentPath;                       {Check the Default Path}
        end;
        if (not found) and (Copy(filename,1,1)<>'\') then begin
          path  := FirstPath;                {Check the Path}
          found := FileExists(path+filename);
          while not (EONamed or found) do begin
            path  := NextPath;
            found := FileExists(path+filename);
          end;
        end;
        if not found then begin               {Check the Program's Directory}
          found := FileExists(MyDir+filename);
          if found then path := MyDir;
        end;
        if found then
          PathTo := path
        else
          PathTo := '';
      end;
    end;

  function FFind(filename:string):string;
    var p : string;
        d : DirStr;
        n : NameStr;
        x : ExtStr;
    begin
      p := PathTo(filename);
      if p<>'' then
        if SpecifiesDrive(filename) then
          FFind := FExpand(p+copy(filename,3,255))
        else
          FFind := FExpand(p+filename)
      else if FileExists(filename) then
        FFind := FExpand(filename)
      else
        FFind := FFindErr;
    end;



  function DOS_Version: integer;
      {Returns the version of DOS being used}
    var r : registers;
    begin
      r.ax := $3000;
      MsDos(r);
      with r do
        DOS_Version := al * 100 + ah
    end;


{-----------------------------------------------------------------------------}

  var
      pPath : string;
      pDir  : DirStr;
      pName : NameStr;
      pExt  : ExtStr;

  procedure GetPName;
    var
      c : ^char;
      i : word;
    begin
      if DOS_Version<300 then begin {Only for DOS 3.x and greater}
        pPath := '';
        pName := '';
       end
      else begin
        c := EnvStrPtr;
        {Skip to the end of the Environment}
          repeat
            while c^<>#0 do
              PtrInc(pointer(c),1);
            PtrInc(pointer(c),1);
          until c^=#0;
          PtrInc(Pointer(c),3);
        pPath := FExpand(StrZ(AsciiPtr(c)^));
        FSplit(pPath,pDir,pName,pExt);
      end;
    end;



  function ProgPath: PathStr;    {Path to program owning current PSP}
    begin
      GetPName;  ProgPath := pPath;
    end;

  function ProgDir:  DirStr;        {Directory of program owning current PSP}
    begin
      GetPName;  ProgDir := pDir;
    end;

  function ProgName: NameStr;       {Name of program owning current PSP}
    begin
      GetPName;  ProgName := pName;
    end;

  function ProgExt:  ExtStr;        {Extension of program owning current PSP}
    begin
      GetPName;  ProgExt := pExt;
    end;


{-----------------------------------------------------------------------------}

{$IFDEF VER40}  {These objects are already in TP Version 5's Dos Unit}


function DosVersion: word;  { lo = version (ex. 3);  hi = fraction (ex. .2) }
    var r : registers;
    begin
      r.ax := $3000;
      MsDos(r);
      DOSVersion := r.ax;
    end;


function EnvCount: integer;              {number of Environment Strings}
  var i: integer;
  begin
    UseMyPSP;
    EnvPtr := EnvStrPtr;
    i := 0;
    while not EoEnv do begin
      SkipEnv;
      i := succ(i);
    end;
    EnvCount := i;
  end;


function EnvStr(Index:integer): string;  {get Env. String number index}
  begin
    UseMyPSP;
    EnvPtr := EnvStrPtr;
    while (index>1) and not EoEnv do begin
      SkipEnv;
      index := pred(index);
    end;
    if index = 1 then
      EnvStr := NextEnv
    else
      EnvStr := '';
  end;


function GetEnv(EnvVar:string): string;  {get Env. String named by EnvVar}
  begin
    GetEnv := FirstNamed(EnvVar,#0);
  end;


function FExpand(Path:PathStr):PathStr;
  var
    i : integer;
    old: PathStr;
  begin
    FSplit(path,pDir,pName,pExt);
    if length(pDir)=0 then
      GetDir(0,pDir)
    else begin
      if pDir[length(pDir)]='\' then  pDir[0] := chr(length(pDir)-1);
      GetDir(0,old);
      ChDir(pDir);
      GetDir(0,pDir);
      ChDir(old);
    end;
    path := pName+pExt;
    for i := 1 to length(path) do path[i] := UpCase(path[i]);
    FExpand := pDir+'\'+path;
  end;


  function FSearch(Path:PathStr;DirList:string):PathStr;
    var dir: string;
        i: integer;
        found: boolean;
    procedure NextDir;
      var j : integer;
      begin
        i := succ(i);  j := i;
        while (j<length(DirList)) and (DirList[j]<>';') do j := succ(j);
        Dir := DirDelim(Copy(Dirlist,i,j-i))+Path;
        i := j;
      end;
    begin
      FSearch := '';
      if Path<>'' then begin
        found := FileExists(path);       {Check Current Directory}
        if Found then
          Dir := Path
        else begin                       {Check DirList}
          i := 0;
          repeat
            NextDir;
            found := FileExists(Dir);
          until (i>=length(DirList)) or found;
        end;
        if found then
          FSearch := Dir;
      end;
    end;


procedure FSplit(Path:PathStr; var Dir:DirStr; var Name:NameStr; var Ext:ExtStr);
  var i,j : integer;
      done : boolean;
  begin
    Dir  := '';  Name := '';  Ext := '';
    if Path='' then exit;
    if Path[length(Path)]='.' then begin
      Dir := Path;
      if length(Path)=1 then exit;
      if Path[length(Path)-1] in ['.','\'] then exit;
      Dir := '';
    end;
    i := length(Path);  j := 0;  done := FALSE;
    while (i>0) and (j<sizeof(Ext)) and not done do begin
      done := (Path[i]='.');
      if done then
        Ext := Copy(Path,i,j+1);
      j := succ(j);
      i := pred(i);
    end;
    i := length(Path) - length(Ext);  j := i;
    while (i>0) and not (Path[i] in [':','\']) do  i := pred(i);
    Name := Copy(Path,i+1,j-i);
    Dir := Copy(Path,1,i);
  end;
{$ENDIF}


{-----------------------------------------------------------------------------}

  begin
    UseMyPSP;
    EnvPtr := EnvStrPtr;
    dummy := 0;
    namePtr := @dummy;
    GetPName;
    MyPath := pPath;
    MyDir := pDir;  MyName := pName;  MyExt := pExt;
  end.